home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / initobj.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  20KB  |  604 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "setp.h"
  17. #include "gutilp.h"
  18. #include "gmiscp.h"
  19. #include "smiscp.h"
  20. #include "gnodesp.h"
  21. #include "initobjp.h"
  22.  
  23. static Tuple proc_init_rec(Symbol, Tuple, Node, Node);
  24. static Node initialization_proc(Symbol, Symbol, Tuple, Tuple);
  25. static Tuple build_comp_names(Node);
  26. static Node remove_discr_ref(Node, Node);
  27.  
  28. Node build_proc_init_ara(Symbol type_name)                /*;build_proc_init_ara*/
  29. {
  30.     /*
  31.      *  This is the   main procedure for  building default  initialization
  32.      *  procedures for array  types. Those  initialization  procedures are
  33.      *  built if  the type  given  contains  some subcomponent for which a
  34.      *  default initialization exists (at any level of nesting),  or if it
  35.      *  has determinants.
  36.      *  Note that scalar objects are not initialized at all, which implies
  37.      *  that they get whatever initial value is in that location in memory
  38.      *  This saves some time in object creation.
  39.      *
  40.      *  All init. procedures  have an 'out' parameter that  designates the
  41.      *  object being initialized (the space has already been allocated).
  42.      *
  43.      */
  44.  
  45.     int        side_effect;
  46.     Tuple    tup, formals, subscripts;
  47.     Symbol    c_type, ip, index_t, proc_name, index_sym;
  48.     Node    one_component, init_stmt, out_param, i_nodes, d_node, iter_node;
  49.     Fortup    ft1;
  50.     Node    iterator, index_node;
  51.  
  52. #ifdef TRACE
  53.     if (debug_flag) {
  54.         gen_trace_symbol("BUILD_PROC_INIT_ARR", type_name);
  55.     }
  56. #endif
  57.  
  58.     side_effect = FALSE;     /* Let's hope... TBSL */
  59.  
  60.     tup = SIGNATURE(type_name);
  61.     c_type    = (Symbol) tup[2];
  62.     one_component = new_node(as_index);
  63.  
  64.     ip = INIT_PROC(base_type(c_type));
  65.     if (ip != (Symbol)0 ){
  66.         /* Use the initialization procedure for the component type */
  67.         init_stmt = (Node) build_init_call(one_component, ip, c_type, OPT_NODE);
  68.     }
  69.     else if (is_task_type(c_type)) {
  70.         /* initialization is task creation. */
  71.         init_stmt =
  72.           new_assign_node(one_component, new_create_task_node(c_type));
  73.     }
  74.     else if (is_access_type(c_type)) {
  75.         /* default value is the null pointer. */
  76.         init_stmt = new_assign_node(one_component, new_null_node(c_type));
  77.     }
  78.     else {
  79.         init_stmt = (Node) 0;
  80.     }
  81.  
  82.     if (init_stmt != (Node)0) {
  83.         /* body of initialization procedure is a loop over the indices */
  84.         /* allocating each component. Generate loop variables and code */
  85.         /* for iteration, using the attributes of the type. */
  86.  
  87.         proc_name = new_unique_name("type_name+INIT");
  88.         out_param = new_param_node("param_type_name", proc_name,
  89.            type_name, na_out);
  90.         generate_object(N_UNQ(out_param));
  91.         formals               = tup_new1((char *) out_param);
  92.         subscripts            = tup_new(0);
  93.         FORTUP(index_t=(Symbol), index_types(type_name), ft1);
  94.             /*index          = index_t + 'INDEX';*/
  95.             index_sym          = new_unique_name("index_t+INDEX");
  96.             NATURE (index_sym) = na_obj;
  97.             TYPE_OF(index_sym) = index_t;
  98.             subscripts = tup_with(subscripts, (char *)new_name_node(index_sym));
  99.         ENDFORTUP(ft1);
  100.  
  101.         i_nodes         = new_node(as_list);
  102.         /* need tup_copy since subscripts used destructively below */
  103.         N_LIST(i_nodes) = tup_copy(subscripts);
  104.  
  105.         /* Build the tree for the one_component of the array. */
  106.         N_AST1(one_component) = out_param;
  107.         N_AST2(one_component) = i_nodes;
  108.         N_TYPE(one_component) = c_type;
  109.  
  110.         while (tup_size(subscripts)) {
  111.             /* Build loop from innermost index outwards. The iterations */
  112.             /* span the ranges of the array being initialized. */
  113.  
  114.             /* dimension spanned by this loop: */
  115.             d_node   = new_ivalue_node(int_const(tup_size(subscripts)), 
  116.               symbol_integer);
  117.             iterator = new_attribute_node(ATTR_O_RANGE,
  118.               new_name_node(N_UNQ(out_param)), d_node, type_name);
  119.  
  120.             index_node = (Node) tup_frome(subscripts);
  121.             iter_node        = new_node(as_for);
  122.             N_AST1(iter_node) = index_node;
  123.             N_AST2(iter_node) = iterator;
  124.  
  125.             init_stmt = new_loop_node(OPT_NODE, iter_node, 
  126.               tup_new1((char *)init_stmt));
  127.         }
  128.  
  129.         INIT_PROC(type_name) = proc_name;
  130.         return initialization_proc(proc_name, type_name,
  131.           formals, tup_new1((char *) init_stmt));
  132.     }
  133.     else {
  134.         return OPT_NODE;
  135.     }
  136.  
  137. }
  138.  
  139. Node build_proc_init_rec(Symbol type_name)                /*;build_proc_init_rec*/
  140. {
  141.     /*
  142.      *  This is the   main procedure for  building default  initialization
  143.      *  procedures for record  types. Those initialization  procedures are
  144.      *  built if  the type  given  contains  some subcomponent for which a
  145.      *  default initialization exists (at any level of nesting),  or if it
  146.      *  has determinants.
  147.      *  Note that scalar objects are not initialized at all, which implies
  148.      *  that they get whatever initial value is in that location in memory
  149.      *  This saves some time in object creation.
  150.      *
  151.      *  All init. procedures  have an 'out' parameter that  designates the
  152.      *  object begin initialized (the space has already been allocated).
  153.      *
  154.      */
  155.  
  156.     int        side_effect;
  157.     Node    invar_node; /* TBSL: is invar_node local??*/
  158.     Tuple    stmts, tup, nstmts, formals, invariant_fields;
  159.     Tuple    discr_list; /* is this local ?? TBSL */
  160.     Fortup    ft1;
  161.     Symbol    d, proc_name;
  162.     Node    param, var_node, out_param;
  163.  
  164.     Node    node, node1, node2, discr_value_node;
  165. #ifdef TRACE
  166.     if (debug_flag)
  167.         gen_trace_symbol("BUILD_PROC_INIT_REC", type_name);
  168. #endif
  169.  
  170.     side_effect = FALSE;     /* Let's hope... TBSL */
  171.  
  172.     /*
  173.      * The initialization procedure for records has the usual out param.,
  174.      * and one in parameter per discriminant. The CONSTRAINED flag is the
  175.      * first of the discriminants
  176.      */
  177.     proc_name = new_unique_name("Init_ type_name");
  178.     out_param = new_param_node("param_type_name", proc_name, type_name, na_out);
  179.     generate_object(proc_name);
  180.     generate_object(N_UNQ(out_param));
  181.     tup = SIGNATURE(type_name);
  182.     invar_node = (Node) tup[1];
  183.     var_node = (Node) tup[2];
  184.     discr_list = (Tuple) tup[3];
  185.     invariant_fields = build_comp_names(invar_node);
  186.  
  187.     stmts = tup_new(0);
  188.     if (tup_size(discr_list)) {
  189.         /* Generate formal parameters for each. The body of the procedure */
  190.         /* assigns them to the field of the object. */
  191.         /* Note: the 'constrained' field is part of the discriminants. */
  192.  
  193.         formals = tup_new(0);
  194.         FORTUP(d=(Symbol), discr_list, ft1);
  195.             param = new_param_node("param_type_name", proc_name, TYPE_OF(d),
  196.               na_in);
  197.             generate_object(N_UNQ(param));
  198.             formals = tup_with(formals, (char *) param );
  199.             stmts = tup_with(stmts,
  200.               (char *) new_assign_node(new_selector_node(out_param, d), param));
  201.             discr_value_node = new_selector_node (out_param, d);
  202.  
  203.             /* generate code in order to test if the value of discriminant is
  204.              * compatible with its subtype
  205.              */
  206.  
  207.             node1 = new_attribute_node(ATTR_T_FIRST, new_name_node(TYPE_OF(d)),
  208.               OPT_NODE, TYPE_OF(d));
  209.             node2 = new_attribute_node(ATTR_T_LAST, new_name_node(TYPE_OF(d)),
  210.               OPT_NODE, TYPE_OF(d));
  211.             node = node_new (as_list);
  212.             make_if_node(node,
  213.               tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_or,
  214.                  new_binop_node(symbol_lt, discr_value_node, node1,
  215.                  symbol_boolean),
  216.                 new_binop_node(symbol_gt, discr_value_node, node2,
  217.                  symbol_boolean),
  218.                 symbol_boolean),
  219.                 new_raise_node(symbol_constraint_error))), OPT_NODE);
  220.             stmts = tup_with(stmts, (char *) node);
  221.         ENDFORTUP(ft1);
  222.         formals = tup_with(formals, (char *) out_param );
  223.  
  224.         /* if there are default expressions for any other components, */
  225.         /* further initialization steps are needed. */
  226.         tup = proc_init_rec(type_name, invariant_fields, var_node, out_param);
  227.         /*stmts += proc_init_rec(invariant_fields, var_node, out_param);*/
  228.         nstmts = tup_add(stmts, tup);
  229.         tup_free(stmts); 
  230.         tup_free(tup); 
  231.         stmts = nstmts;
  232.     }
  233.     else {
  234.         /* record without discriminants. There may still be default values */
  235.         /* for some components. */
  236.         formals = tup_new1((char *) out_param);
  237.         stmts   = proc_init_rec(type_name,invariant_fields,var_node, out_param);
  238.     }
  239.     if (tup_size(stmts)) {
  240.         INIT_PROC(type_name) = proc_name;
  241.         return initialization_proc(proc_name, type_name, formals, stmts);
  242.     }
  243.     else {
  244.         return OPT_NODE;
  245.     }
  246. }
  247.  
  248. static Tuple proc_init_rec(Symbol type_name, Tuple field_names,
  249.   Node variant_node, Node out_param)                    /*;proc_init_rec*/
  250. {
  251.     /*
  252.      *  This is a subsidiary procedure to BUILD_PROC_INIT, which performs
  253.      *  the recursive part of construction of an initialization procedure
  254.      *  for a record type.
  255.      *
  256.      *  Input: field_names is a list of component unique names (excluding
  257.      *         discriminants. Variant node is the AST for the variant part
  258.      *         of a component list.
  259.      *      variant_node is the variant part of the record declaration
  260.      *      and has the same structure as a case statement.
  261.      *
  262.      *         out_param designates the object being initialized
  263.      *
  264.      *  Output: the statement list required to initialize this fragment of
  265.      *          the record, or [] if not default initialization is needed.
  266.      */
  267.  
  268.     Tuple    init_stmt, stmts;
  269.     Node        one_component, f_init, c_node, variant_list;
  270.     Symbol    f_type, f_name, ip;
  271.     Fortup    ft1;
  272.     int        empty_case;
  273.     Tuple    case_list, comp_case_list;
  274.     Node        choice_list, comp_list, disc_node;
  275.     Node        invariant_node, new_case, list_node, case_node;
  276.  
  277.     Tuple    tup, index_list;
  278.     int        nb_dim, i;
  279.     Node        d_node,  node, node1, node2, node3, node4, node5;
  280.     Symbol    one_index_type;
  281.  
  282.     /* process fixed part first. */
  283.     init_stmt = tup_new(0);
  284.     FORTUP(f_name=(Symbol), field_names, ft1);
  285.         one_component    = new_selector_node(out_param, f_name);
  286.         f_type           = TYPE_OF(f_name);
  287.                 CONTAINS_TASK(type_name) = (char *)
  288.                   ((int)CONTAINS_TASK(type_name) | (int) CONTAINS_TASK(f_type));
  289.  
  290.         f_init = (Node) default_expr(f_name);
  291.         if (f_init  != OPT_NODE) {
  292.             init_stmt = tup_with(init_stmt,
  293.               (char *) new_assign_node(one_component,
  294.                remove_discr_ref(f_init, out_param)));
  295.         }
  296.         else if ((ip = INIT_PROC(base_type(f_type)))!=(Symbol)0) {
  297.             init_stmt  = tup_with(init_stmt,
  298.               (char *) build_init_call(one_component, ip, f_type, out_param));
  299.         }
  300.         else if (is_task_type(f_type)) {
  301.             init_stmt  = tup_with(init_stmt, (char *)
  302.               new_assign_node(one_component, new_create_task_node(f_type)));
  303.         }
  304.         else if (is_access_type(f_type)) {
  305.             init_stmt  = tup_with(init_stmt, (char *)
  306.               new_assign_node(one_component, new_null_node(f_type)));
  307.         }
  308.  
  309.  
  310.         /* if we have an aray then we have to check if its bounds are
  311.          * compatible with the index subtypes (of the unconstrained array) 
  312.          * (This code was generated beforehand in type.c ("need_qual_r") but
  313.          * it was wrong : we have to test the bounds only if the field is
  314.          * present (case of variant record).
  315.          * The generation of the tests is easier here
  316.          */
  317.  
  318.         if (is_array_type (f_type)) {
  319.             tup = (Tuple) SIGNATURE(TYPE_OF(f_type));
  320.             index_list = tup_copy((Tuple) tup[1]);
  321.             nb_dim = tup_size(index_list);
  322.  
  323.             for (i = 1; i <= nb_dim; i++) {
  324.                 one_index_type = (Symbol) (tup_fromb (index_list));
  325.  
  326.                 d_node   = new_ivalue_node(int_const(i), symbol_integer);
  327.  
  328.                 node1 = new_attribute_node(ATTR_O_FIRST,
  329.                   one_component, d_node, one_index_type);
  330.  
  331.                 node2 = new_attribute_node(ATTR_O_LAST,
  332.                   one_component, d_node, one_index_type);
  333.  
  334.                 node3 = new_attribute_node(ATTR_T_FIRST,
  335.                   new_name_node(one_index_type), OPT_NODE, one_index_type);
  336.  
  337.                 node4 = new_attribute_node(ATTR_T_LAST,
  338.                   new_name_node(one_index_type), OPT_NODE, one_index_type);
  339.  
  340.                 node5 = new_binop_node(symbol_or,
  341.                   new_binop_node(symbol_lt, node1, node3, symbol_boolean),
  342.                   new_binop_node(symbol_gt, node2, node4, symbol_boolean),
  343.                   symbol_boolean);
  344.  
  345.                 node = node_new (as_list);
  346.                 make_if_node(node,
  347.                 tup_new1((char *) new_cond_stmts_node(
  348.                   new_binop_node(symbol_and,
  349.                   new_binop_node(symbol_le, node1, node2, symbol_boolean),
  350.                   node5, symbol_boolean),
  351.                   new_raise_node(symbol_constraint_error))), OPT_NODE);
  352.                 init_stmt  = tup_with(init_stmt, (char *) (node));
  353.             }
  354.         }
  355.     ENDFORTUP(ft1);
  356.  
  357.     /* then build case statement to parallel structure of variant part. */
  358.  
  359.     empty_case = TRUE;    /* assumption */
  360.     if (variant_node != OPT_NODE) {
  361.  
  362.         disc_node= N_AST1(variant_node);
  363.         variant_list = N_AST2(variant_node);
  364.  
  365.         case_list = tup_new(0);
  366.  
  367.         comp_case_list = N_LIST(variant_list);
  368.  
  369.         FORTUP(c_node=(Node), comp_case_list, ft1);
  370.             choice_list = N_AST1(c_node);
  371.             comp_list = N_AST2(c_node);
  372.             invariant_node = N_AST1(comp_list);
  373.             variant_node = N_AST2(comp_list);
  374.  
  375.             field_names = build_comp_names(invariant_node);
  376.             stmts = proc_init_rec(type_name,field_names,variant_node, out_param);
  377.  
  378.             /*empty_case and= stmts = [];*/
  379.             empty_case = empty_case ? (tup_size(stmts)==0) : FALSE;
  380.             new_case = (N_KIND(c_node) == as_others_choice) ?
  381.               new_node(as_others_choice) : new_node(as_variant_choices);
  382.             N_AST1(new_case) = copy_tree(choice_list);
  383.             N_AST2(new_case) = new_statements_node(stmts);
  384.             case_list = tup_with(case_list, (char *)  new_case );
  385.         ENDFORTUP(ft1);
  386.  
  387.         if (! empty_case) {
  388.             /* Build a case statement ruled by the value of the discriminant */
  389.             /* for this variant part. */
  390.  
  391.             list_node         = new_node(as_list);
  392.             N_LIST(list_node) = case_list;
  393.             case_node         = new_node(as_case);
  394.             N_AST1(case_node)  = new_selector_node(out_param, N_UNQ(disc_node));
  395.             N_AST2(case_node) = list_node;
  396.             init_stmt    = tup_with(init_stmt, (char *) case_node );
  397.         }
  398.     }
  399.     return init_stmt;
  400. }
  401.  
  402. int is_discr_ref(Node expr_node)                            /*;is_discr_ref*/
  403. {
  404.     int     n, i, nk;
  405.     Node    node;
  406.     Tuple    tup;
  407.  
  408.     if (N_KIND(expr_node) == as_discr_ref)
  409.         return TRUE;
  410.  
  411.     nk = N_KIND(expr_node);
  412.     node = N_AST1(expr_node);
  413.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  414.     node = N_AST2_DEFINED(nk) ? N_AST2(expr_node) : (Node) 0;
  415.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  416.     node = N_AST3_DEFINED(nk) ? N_AST3(expr_node) : (Node) 0;
  417.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  418.     node = N_AST4_DEFINED(nk) ? N_AST4(expr_node) : (Node) 0;
  419.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  420.     tup = N_LIST_DEFINED(nk) ? N_LIST(expr_node) : (Tuple) 0;
  421.     if (tup==(Tuple)0) return FALSE;
  422.     n = tup_size(tup);
  423.     for (i = 1; i <= n; i++)
  424.         if (is_discr_ref((Node) tup[i])) return TRUE;
  425.     return FALSE;
  426. }
  427.  
  428. static Node remove_discr_ref(Node expr_node, Node object) /*;remove_discr_ref*/
  429. {
  430.     /* Within the record definition, a discriminant reference can be replaced
  431.      * by a selected component for the instance of the record being built.
  432.      */
  433.  
  434.     Node        e;
  435.     int        i, nk;
  436.     Tuple    tup;
  437.  
  438.     if (N_KIND(expr_node) == as_discr_ref)
  439.         return new_selector_node(object, N_UNQ(expr_node));
  440.     else if (N_KIND(expr_node) == as_opt)
  441.         return OPT_NODE;
  442.     else {
  443.         e = copy_node(expr_node);
  444.         nk = N_KIND(e);
  445.         if (N_AST1_DEFINED(nk) && N_AST1(e)!=(Node)0)
  446.             N_AST1(e) = remove_discr_ref(N_AST1(e), object);
  447.         if (N_AST2_DEFINED(nk) && N_AST2(e)!=(Node)0)
  448.             N_AST2(e) = remove_discr_ref(N_AST2(e), object);
  449.         if (N_AST3_DEFINED(nk) && N_AST3(e)!=(Node)0)
  450.             N_AST3(e) = remove_discr_ref(N_AST3(e), object);
  451.         if (N_AST4_DEFINED(nk) && N_AST4(e)!=(Node)0)
  452.             N_AST4(e) = remove_discr_ref(N_AST4(e), object);
  453.     }
  454.     /*N_LIST(e) = [remove_discr_ref(n, object): n in N_LIST(e)];*/
  455.     if (N_LIST_DEFINED(nk) && N_LIST(e)!=(Tuple)0) {
  456.         tup = N_LIST(e);
  457.         for (i = 1; i <= tup_size(tup); i++)
  458.             tup[i] = (char *) remove_discr_ref((Node) tup[i], object);
  459.     }
  460.     return e;
  461. }
  462.  
  463. static Node initialization_proc(Symbol proc_name, Symbol type_name,
  464.   Tuple formals, Tuple stmts)                            /*;initialization_proc*/
  465. {
  466.     /* Build procedure with given formals and statement list. */
  467.  
  468.     Node    proc_node;
  469.  
  470.     int        i, n;
  471.     Tuple    tup;
  472.     NATURE   (proc_name)  = na_procedure;
  473.     n = tup_size(formals);
  474.     tup = tup_new(n);
  475.  
  476.     for (i = 1; i <= n; i++)
  477.         tup[i] = (char *) N_UNQ((Node)formals[i]);
  478.     SIGNATURE(proc_name)  = tup;
  479.     generate_object(proc_name);
  480.  
  481.     /* 
  482.      * Create as_subprogram_tr node with statements node as N_AST1 
  483.      * instead of N_AST3 as it is with as_subprogram.
  484.      */
  485.     proc_node         = new_node(as_subprogram_tr);
  486.     N_UNQ(proc_node) = proc_name;
  487.     N_AST1(proc_node)  = new_statements_node(stmts);
  488.     N_AST2(proc_node)  = OPT_NODE;
  489.     N_AST4(proc_node)  = OPT_NODE;
  490.  
  491.     return proc_node;
  492. }
  493.  
  494. Node build_init_call(Node one_component, Symbol proc_name, Symbol c_type,
  495.   Node object)                                                /*;build_init_call*/
  496. {
  497.     /*
  498.      * Construct statement to initialize an object component for which
  499.      * an initialization procedure exists. The statement is a call to that
  500.      * procedure.
  501.      * c_type is the (composite) type of the component.
  502.      * If this is a record type whose discriminants have default values,
  503.      * use these defaults as parameters of the initialization procedure.
  504.      *
  505.      * If it is a subtype, use  the discriminant  values  elaborated for
  506.      * the subtype template.
  507.      *
  508.      * In the case of record component that is a record subtype, the const-
  509.      * raint may be given by a discriminant of the outer record. Such const-
  510.      * raints can only be evaluated when the outer object itself is being
  511.      * elaborated. In  that case  the  value of discriminant is rewritten as
  512.      * a selected  component of the enclosing object.
  513.      *
  514.      * The constrained bit is treated like other discriminants. Its value is
  515.      * FALSE for a record type, TRUE for a record subtype.
  516.      *
  517.      * If this is an array type, the procedure has one_component as its
  518.      * single actual.
  519.      */
  520.  
  521.     Tuple    disc_vals, tup, discr_map, arg_list;
  522.     Fortup    ft1;
  523.     Symbol    d;
  524.     Node    node, p_node, args_node, d_val, d_val_new;
  525.     int        i, n;
  526.  
  527. #ifdef TRACE
  528.     if (debug_flag)
  529.         gen_trace_symbol("BUILD_INIT_CALL", proc_name);
  530. #endif
  531.  
  532.     if (is_record_type(c_type)) {
  533.         if (is_record_subtype(c_type)) {
  534.             /* examine constraint of subtype. */
  535.             disc_vals = tup_new(0);
  536.             tup = SIGNATURE(c_type);
  537.             discr_map = (Tuple) tup[2];
  538.  
  539.             FORTUP(d=(Symbol), discriminant_list_get(c_type), ft1);
  540.                 d_val = discr_map_get(discr_map, d);
  541.                 if (is_discr_ref(d_val) ) {
  542.                     /* depends on determinant of outer object */
  543.                     d_val_new = remove_discr_ref(d_val, object);
  544.                 }
  545.                 else if (is_ivalue(d_val) ) {
  546.                     /* useless to retrieve from subtype here */
  547.                     d_val_new = d_val;
  548.                 }
  549.                 else {
  550.                     /* elaborated: retrieve from subtype. */
  551.                     d_val_new = new_discr_ref_node(d, c_type);
  552.                 }
  553.                 disc_vals = tup_with(disc_vals, (char *) d_val_new);
  554.             ENDFORTUP(ft1);
  555.         }
  556.         else {
  557.             /* Use default values to initialize discriminants. */
  558.             tup = discriminant_list_get(c_type);
  559.             n = tup_size(tup);
  560.             disc_vals = tup_new(n);
  561.             for (i = 1; i <= n; i++)
  562.                 disc_vals[i] = (char *) default_expr((Symbol) tup[i]);
  563.         }
  564.         arg_list = disc_vals;/* last use of disc_vals so no need to copy*/
  565.         arg_list = tup_with(arg_list, (char *) one_component);
  566.     }
  567.     else {
  568.         arg_list = tup_new1((char *) one_component);
  569.     }
  570.  
  571.     /* Build call to initialization procedure. */
  572.     node              = new_node(as_init_call);
  573.     p_node            = new_name_node(proc_name);
  574.     args_node         = new_node(as_list);
  575.     N_LIST(args_node) = arg_list;
  576.     N_AST1(node)       = p_node;
  577.     N_AST2(node)       = args_node;
  578.     N_SIDE(node)      = FALSE;
  579.     return node;
  580. }
  581.  
  582. static Tuple build_comp_names(Node invariant_node)        /*;build_comp_names*/
  583. {
  584.     /* Collect names of record components in the invariant part of the
  585.      * record. Skip nodes generated for internal anonymous subtypes.
  586.      */
  587.  
  588.     Tuple    all_component_names;
  589.     Node    node, id_list_node, id_node;
  590.     Fortup    ft1, ft2;
  591.  
  592.     all_component_names = tup_new(0);
  593.     FORTUP(node=(Node), N_LIST(invariant_node), ft1);
  594.         if(N_KIND(node) ==as_subtype_decl || N_KIND(node)==as_deleted)
  595.             continue;
  596.         id_list_node= N_AST1(node);
  597.         FORTUP(id_node=(Node), N_LIST(id_list_node), ft2);
  598.             all_component_names  = tup_with(all_component_names,
  599.               (char *) N_UNQ(id_node));
  600.         ENDFORTUP(ft2);
  601.     ENDFORTUP(ft1);
  602.     return all_component_names;
  603. }
  604.